Delphi Informant Complete 1995 - 2000/Delphi Informant Complete 1995 to 2000.iso/Delphi Informant Magazine Complete Works SOURCE CODE 1998.rar/1998/Nov/di9811gd/Example2/Unit2.pas

Pascal/Delphi Source File | 1998-04-25 | 9KB | 293 lines

unit Unit2;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  { TLightThread }
  {* For easy management of threads.                                          *}
  {* Allows a thread to be "created" with a passed thread function. The       *}
  {* function will exit cleanly when ThreadExiting is set to true, or         *}
  {* "nastily" after a timeout of ThreadExitTimeout milliseconds.             *}
  {* For the purposes of this example, though, we are pretty assured that the *}
  {* ThreadFunc used will always exit cleanly... (How else to demonstrate     *}
  {* a thread-safe DLL?)                                                      *}
  TLightThread = class(TObject)
  protected
    FThreadHandle: THandle;
    FThreadID: DWord;
    FCS: TRTLCriticalSection;
    FThreadExiting: Boolean;
    FCallGetFirstWord,
    FCallGetNextWord: Boolean;
    function GetThreadExiting: Boolean;
  public
    constructor Create(ThreadFunc: TThreadFunc);
    destructor Destroy; override;
    property ThreadExiting: Boolean read GetThreadExiting;
    property ThreadHandle: THandle read FThreadHandle;
    property ThreadID: DWord read FThreadID;
    property CallGetFirstWord: Boolean read FCallGetFirstWord
                                       write FCallGetFirstWord;
    property CallGetNextWord: Boolean read FCallGetNextWord
                                       write FCallGetNextWord;
  end;

  TGetWordProc = procedure(sz, szResult: PChar); stdcall;

  { TForm1 }
  TForm1 = class(TForm)
    btnLoad: TButton;
    btnUnload: TButton;
    lbThreads: TListBox;
    Label1: TLabel;
    btnNewThread: TButton;
    btnCloseThread: TButton;
    Label2: TLabel;
    Edit1: TEdit;
    btnGetFirstWord: TButton;
    btnGetNextWord: TButton;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure btnLoadClick(Sender: TObject);
    procedure btnUnloadClick(Sender: TObject);
    procedure btnNewThreadClick(Sender: TObject);
    procedure btnCloseThreadClick(Sender: TObject);
    procedure btnGetFirstWordClick(Sender: TObject);
    procedure btnGetNextWordClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    LibHandle: THandle;
    ThreadList: TList;
    procedure FreeLib;
    procedure NewThread;
    procedure CloseThread(Idx: Integer); { Close indexed thread. }
    procedure CloseThreads;
  end;

var
  GetFirstWord: TGetWordProc;
  GetNextWord: TGetWordProc;
  Form1: TForm1;

const
  ThreadSleepLength = 50; // 50 ms.
  ThreadExitTimeout = 10000;

implementation

{$R *.DFM}

procedure ShowThreadMessage(Msg: String);
begin
  MessageBox(Form1.Handle, PChar(Msg), 'Message',
             MB_OK or MB_SETFOREGROUND or MB_TASKMODAL);
end;

function ThreadFunc(Parameter: Pointer): Integer;
var
  szResult: PChar;
begin
  while (not TLightThread(Parameter).ThreadExiting) do begin
    with (TLightThread(Parameter)) do begin
      {* This section of code is critical code--                              *}
      {*   Because it accesses "global" memory, the thread should make sure   *}
      {*   that it is the only thread trying to access this memory.           *}
      {*   Obviously, I'm following bad programming practice right here, but  *}
      {*   for the sake of the example, I have avoided using good programming *}
      {*   technique because that's not the item being demonstrated...        *}
      {*   Shoot me if you will...                                            *}
      {*                                                                      *}
      if CallGetFirstWord or CallGetNextWord then begin
        GetMem(szResult, Length(Form1.Edit1.Text) + 1);
        try
          if CallGetFirstWord then
            GetFirstWord(PChar(Form1.Edit1.Text), szResult)
          else if CallGetNextWord then
            GetNextWord(PChar(Form1.Edit1.Text), szResult);
          ShowThreadMessage(String(szResult));
          CallGetFirstWord := False;
          CallGetNextWord := False;
        finally
          FreeMem(szResult, Length(Form1.Edit1.Text) + 1);
        end;
      end;
    end;
    Sleep(ThreadSleepLength);
  end;
  result := 0;
end;

{ TLightThread }
constructor TLightThread.Create(ThreadFunc: TThreadFunc);
begin
  InitializeCriticalSection(FCS);
  FThreadExiting := False;
  try
    FThreadHandle :=
      BeginThread(nil, 0, ThreadFunc, Pointer(Self), 0, FThreadID);
  except
    on E: Exception do begin
      DeleteCriticalSection(FCS);
      raise;
    end;
  end;
end;

destructor TLightThread.Destroy;
begin
  EnterCriticalSection(FCS);
  try
    FThreadExiting := True;
  finally
    LeaveCriticalSection(FCS);
  end;
  WaitForSingleObject(FThreadHandle, ThreadExitTimeout);
  CloseHandle(FThreadHandle);
  DeleteCriticalSection(FCS);
  inherited;
end;

function TLightThread.GetThreadExiting: Boolean;
begin
  EnterCriticalSection(FCS);
  try
    result := FThreadExiting;
  finally
    LeaveCriticalSection(FCS);
  end;
end;

{ TForm1 }

procedure TForm1.FormCreate(Sender: TObject);
begin
  LibHandle := 0;
  ThreadList := TList.Create;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  FreeLib;                           // Free the library, if necessary
  CloseThreads;
  ThreadList.Free;                   // Free the list of threads.
end;

procedure TForm1.btnLoadClick(Sender: TObject);
begin
  if LibHandle = 0 then
    LibHandle := LoadLibrary('Dll2.dll');
  if (LibHandle = 0) then
    raise Exception.Create('Unable to load library.')
  else begin
    Edit1.Enabled := True;
    btnGetFirstWord.Enabled := True;
    btnGetNextWord.Enabled := True;
    GetFirstWord := GetProcAddress(LibHandle, 'GetFirstWord');
    GetNextWord := GetProcAddress(LibHandle, 'GetNextWord');
  end;
end;

procedure TForm1.btnUnloadClick(Sender: TObject);
begin
  try
    FreeLib;
    GetFirstWord := nil;
    GetNextWord := nil;
  finally
    LibHandle := 0;
    Edit1.Enabled := False;
    btnGetFirstWord.Enabled := False;
    btnGetNextWord.Enabled := False;
  end;
end;

procedure TForm1.btnNewThreadClick(Sender: TObject);
begin
  NewThread;
end;

procedure TForm1.btnCloseThreadClick(Sender: TObject);
begin
  CloseThread(lbThreads.ItemIndex);
end;

procedure TForm1.FreeLib;
var
  i, Cnt: Integer;
begin
  {* In comments is the appropriate way for a calling application
     to free its library when it has multiple threads; however, for
     the purpose of the example, we _just_ unload the library *}
  FreeLibrary(LibHandle);
  LibHandle := 0;
  {if LibHandle <> 0 then begin
    try
      Cnt := ThreadList.Count;
      for i := 0 to Cnt - 1 do CloseThread(0);
      FreeLibrary(LibHandle);
    finally
      LibHandle := 0;
    end;
  end;}
end;

procedure TForm1.NewThread;
var
  Thd: TLightThread;
begin
  { Create a thread }
  Thd := TLightThread.Create(ThreadFunc);
  { If thread was created successfully, then add the thread handle to
    ThreadList, increment thread count and add an "identifier" to
    the ListBox (for identification purposes only). }
  ThreadList.Add(Pointer(Thd));
  lbThreads.Items.Add('Thread #' + IntToStr(Thd.ThreadHandle));
  lbThreads.ItemIndex := lbThreads.Items.Count - 1;
end;

procedure TForm1.CloseThread(Idx: Integer);
begin
  if (Idx >= 0) and (Idx < ThreadList.Count) then begin
    TLightThread(ThreadList.Items[Idx]).Free;
    ThreadList.Delete(Idx);  ThreadList.Pack;
    lbThreads.Items.Delete(Idx);
    if (Idx = ThreadList.Count) then
      lbThreads.ItemIndex := Idx - 1
    else
      lbThreads.ItemIndex := Idx;
  end;
end;

procedure TForm1.CloseThreads;
var
  i, Cnt: Integer;
begin
  Cnt := ThreadList.Count;
  for i := 0 to Cnt - 1 do CloseThread(0);
end;

procedure TForm1.btnGetFirstWordClick(Sender: TObject);
begin
  if Assigned(GetFirstWord) and (lbThreads.ItemIndex > -1) then
    TLightThread(ThreadList.Items[lbThreads.I